home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacMETH 3.2.1 / Sources / MacC2.6 / M2TM.MOD < prev   
Encoding:
Modula Implementation  |  1992-05-29  |  10.2 KB  |  306 lines  |  [TEXT/MEDT]
  1. IMPLEMENTATION MODULE M2TM; (* NW 7.4.83 / 19.12.85; WH 10.1.86 *)
  2.                             (* HS 1.7.86 / 19.12.91 *)
  3.  
  4.   (* Implementation for the MOTOROLA 68000/68010/68020/68040 processors. *)
  5.  
  6.   FROM M2DM IMPORT
  7.        WordSize, NilVal, ObjPtr, Object, ObjClass, StrPtr, Structure, StrForm,
  8.        Standard, ParPtr, Parameter, PDesc, PDPtr, KeyPtr, Key,
  9.        mainmod, sysmod,
  10.        undftyp, cardtyp, cardinttyp, inttyp, booltyp, chartyp, bitstyp, realtyp,
  11.        lrltyp, lcardtyp, dbltyp, proctyp, notyp, stringtyp, addrtyp, bytetyp,
  12.        wordtyp, ALLOCATE, ResetHeap;
  13.   FROM M2SM IMPORT
  14.        id, Diff, Enter, Mark;
  15.  
  16.   VAR obj:    ObjPtr;
  17.     universe: ObjPtr;
  18.     BBtyp:    StrPtr;
  19.     expo:     BOOLEAN;
  20.  
  21.   PROCEDURE FindInScope(id: INTEGER; root: ObjPtr): ObjPtr;
  22.     VAR obj: ObjPtr; d: INTEGER;
  23.   BEGIN obj := root;
  24.     LOOP IF obj = NIL THEN EXIT END;
  25.       d := Diff(id, obj^.name);
  26.       IF d < 0 THEN obj := obj^.left
  27.       ELSIF d > 0 THEN obj := obj^.right
  28.       ELSE EXIT
  29.       END
  30.     END;
  31.     RETURN obj
  32.   END FindInScope;
  33.  
  34.   PROCEDURE Find(id: INTEGER): ObjPtr;
  35.     VAR obj: ObjPtr;
  36.   BEGIN Scope := topScope;
  37.     LOOP obj := FindInScope(id, Scope^.right);
  38.       IF obj # NIL THEN EXIT END;
  39.       IF Scope^.kind = Module THEN
  40.         obj := FindInScope(id, universe^.right); EXIT
  41.       END;
  42.       Scope := Scope^.left
  43.     END;
  44.     RETURN obj
  45.   END Find;
  46.  
  47.   PROCEDURE FindImport(id: INTEGER): ObjPtr;
  48.     VAR obj: ObjPtr;
  49.   BEGIN Scope := topScope^.left;
  50.     LOOP obj := FindInScope(id, Scope^.right);
  51.       IF obj # NIL THEN EXIT END;
  52.       IF Scope^.kind = Module THEN
  53.         obj := FindInScope(id, universe^.right); EXIT
  54.       END;
  55.       Scope := Scope^.left
  56.     END;
  57.     RETURN obj
  58.   END FindImport;
  59.  
  60.   PROCEDURE NewObj(id: INTEGER; cl: ObjClass): ObjPtr;
  61.     VAR ob0, ob1: ObjPtr; d: INTEGER;
  62.   BEGIN ob0 := topScope; ob1 := ob0^.right; d := 1;
  63.     LOOP
  64.       IF ob1 # NIL THEN
  65.         d := Diff(id, ob1^.name);
  66.         IF d < 0 THEN ob0 := ob1; ob1 := ob0^.left
  67.         ELSIF d > 0 THEN ob0 := ob1; ob1 := ob0^.right
  68.         ELSIF ob1^.class = Temp THEN (*export*)
  69.           (*change variant*) ob1^.exported := TRUE;
  70.           topScope^.last^.next := ob1; topScope^.last := ob1; EXIT
  71.         ELSE (*double def*) Mark(100); EXIT
  72.         END
  73.       ELSE (*insert new object*) ALLOCATE(ob1, SIZE(Object));
  74.         IF d < 0 THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END;
  75.         ob1^.left := NIL; ob1^.right := NIL; ob1^.next := NIL;
  76.         IF cl # Temp THEN
  77.           topScope^.last^.next := ob1; topScope^.last := ob1
  78.         END;
  79.         ob1^.exported := FALSE; EXIT
  80.       END
  81.     END;
  82.     WITH ob1^ DO
  83.       name := id; typ := undftyp; class := cl;
  84.       CASE cl OF
  85.       | Header: kind := Proc; last := NIL; heap := NIL; withadr := 0;
  86.       | Const:  WITH conval DO D0 := 0; D1 := 0; D2 := 0; D3 := 0 END;
  87.       | Typ:    mod := mainmod;
  88.       | Var:    varpar := FALSE;
  89.                 vmod := 0; vlev := 0; vadr := 0;
  90.       | Field:  offset := 0;
  91.       | Proc:   ALLOCATE(pd, SIZE(PDesc)); firstParam := NIL; firstLocal := NIL;
  92.                 pmod := 0;
  93.       | Code:   cd := NIL; firstArg := NIL; std := Halt; cnum := 0;
  94.       | Module: key := NIL; firstObj := NIL; root := NIL; modno := 0;
  95.                 typ := notyp;
  96.       | Temp:   baseref := 0;
  97.       END
  98.     END;
  99.     RETURN ob1
  100.   END NewObj;
  101.  
  102.   PROCEDURE NewStr(frm: StrForm): StrPtr;
  103.     VAR str: StrPtr;
  104.   BEGIN ALLOCATE(str, SIZE(Structure));
  105.     WITH str^ DO
  106.       strobj := NIL; size := 0; ref := 0; form := frm;
  107.       CASE frm OF
  108.         Undef, Bool, Char, Card, CardInt, Int, Enum, LCard, Double,
  109.         Real, LongReal, Opaque, String: |
  110.         Range: RBaseTyp := undftyp; min := 0; max := 0; BndAdr := 0 |
  111.         Pointer: PBaseTyp := undftyp |
  112.         Set:     SBaseTyp := undftyp |
  113.         Array:   ElemTyp := undftyp; IndexTyp := undftyp |
  114.         Record:  firstFld := NIL |
  115.         ProcTyp: firstPar := NIL; resTyp := NIL
  116.       END
  117.     END;
  118.     RETURN str
  119.   END NewStr;
  120.  
  121.   PROCEDURE NewImp(scope, obj: ObjPtr);
  122.     VAR ob0, ob1, ob1L, ob1R: ObjPtr; d: INTEGER;
  123.   BEGIN ob0 := scope; ob1 := ob0^.right; d := 1;
  124.     LOOP
  125.       IF ob1 # NIL THEN
  126.         d := Diff(obj^.name, ob1^.name);
  127.         IF d < 0 THEN ob0 := ob1; ob1 := ob1^.left
  128.         ELSIF d > 0 THEN ob0 := ob1; ob1 := ob1^.right
  129.         ELSIF ob1^.class = Temp THEN (*exported*)
  130.           ob1L := ob1^.left; ob1R := ob1^.right;
  131.           ob1^ := obj^; ob1^.exported := TRUE;
  132.           ob1^.left := ob1L; ob1^.right := ob1R; EXIT
  133.         ELSE Mark(100); EXIT
  134.         END
  135.       ELSE (*insert copy of imported object*)
  136.         ALLOCATE(ob1, SIZE(Object)); ob1^ := obj^;
  137.         IF d < 0 THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END;
  138.         ob1^.left := NIL; ob1^.right := NIL; ob1^.exported := FALSE;
  139.         IF (obj^.class = Typ) & (obj^.typ^.form = Enum) THEN
  140.           (*import enumeration constants too*)
  141.           ob0 := obj^.typ^.ConstLink;
  142.           WHILE ob0 # NIL DO
  143.             NewImp(scope, ob0); ob0 := ob0^.conval.prev
  144.           END
  145.         END;
  146.         EXIT
  147.       END
  148.     END
  149.   END NewImp;
  150.  
  151.   PROCEDURE NewPar(ident: INTEGER; isvar: BOOLEAN; last: ParPtr): ParPtr;
  152.     VAR par: ParPtr;
  153.   BEGIN ALLOCATE(par, SIZE(Parameter)); par^.name := ident;
  154.     par^.varpar := isvar; par^.next := last; RETURN par
  155.   END NewPar;
  156.  
  157.   PROCEDURE NewScope(cl: ObjClass);
  158.     VAR hd: ObjPtr;
  159.   BEGIN ALLOCATE(hd, SIZE(Object));
  160.     WITH hd^ DO
  161.       name := 0; typ := NIL; class := Header;
  162.       left := topScope; right := NIL; last := hd; next := NIL; kind := cl
  163.     END;
  164.     topScope := hd
  165.   END NewScope;
  166.  
  167.   PROCEDURE CloseScope;
  168.   BEGIN topScope := topScope^.left
  169.   END CloseScope;
  170.  
  171.   PROCEDURE CheckUDP(obj, node: ObjPtr);
  172.     (*obj is newly defined type; check for undefined forward references
  173.       pointing to this new type by traversing the tree*)
  174.   BEGIN
  175.     IF node # NIL THEN
  176.       IF (node^.class = Typ) & (node^.typ^.form = Pointer) &
  177.          (node^.typ^.PBaseTyp = undftyp) &
  178.          (Diff(node^.typ^.BaseId, obj^.name) = 0) THEN
  179.         node^.typ^.PBaseTyp := obj^.typ
  180.       END;
  181.       CheckUDP(obj, node^.left); CheckUDP(obj, node^.right)
  182.     END
  183.   END CheckUDP;
  184.  
  185.   PROCEDURE MarkHeap;
  186.   BEGIN ALLOCATE(topScope^.heap, 0); topScope^.name := id
  187.   END MarkHeap;
  188.  
  189.   PROCEDURE ReleaseHeap;
  190.   BEGIN ResetHeap(topScope^.heap); id := topScope^.name
  191.   END ReleaseHeap;
  192.  
  193.   PROCEDURE InitTableHandler;
  194.   BEGIN topScope := universe; mainmod^.firstObj := NIL; ReleaseHeap
  195.   END InitTableHandler;
  196.  
  197.   PROCEDURE EnterTyp(VAR str: StrPtr; name: ARRAY OF CHAR;
  198.                      frm: StrForm; sz: INTEGER);
  199.   BEGIN obj := NewObj(Enter(name), Typ); str := NewStr(frm);
  200.     obj^.typ := str; str^.strobj := obj; str^.size := sz;
  201.     obj^.exported := expo
  202.   END EnterTyp;
  203.  
  204.   PROCEDURE EnterProc(name: ARRAY OF CHAR; num: Standard; res: StrPtr);
  205.   BEGIN obj := NewObj(Enter(name), Code);
  206.     obj^.typ := res; obj^.std := num; obj^.exported := expo
  207.   END EnterProc;
  208.  
  209. BEGIN topScope := NIL; Scope := NIL;
  210.   NewScope(Module); universe := topScope;
  211.   undftyp := NewStr(Undef); undftyp^.size := 1;
  212.   notyp := NewStr(Undef); notyp^.size := 0;
  213.   stringtyp := NewStr(String); stringtyp^.size := 0;
  214.   BBtyp := NewStr(Range); (*Bitset Basetyp*)
  215.   ALLOCATE(mainmod, SIZE(Object));
  216.   WITH mainmod^ DO
  217.     class := Module; modno := 0; typ := notyp; next := NIL; exported := FALSE;
  218.     ALLOCATE(key, SIZE(Key))
  219.   END;
  220.  
  221.   (*initialization of Universe*)
  222.   expo := FALSE;
  223.   EnterTyp(booltyp,  "BOOLEAN",  Bool,     1);
  224.   EnterTyp(chartyp,  "CHAR",     Char,     1);
  225.   EnterTyp(cardtyp,  "CARDINAL", Card,     2);
  226.   EnterTyp(cardinttyp,".CARDINT",CardInt,  2);
  227.   EnterTyp(inttyp,   "INTEGER",  Int,      2);
  228.   EnterTyp(bitstyp,  "BITSET",   Set,      WordSize DIV 8);
  229.   EnterTyp(lcardtyp, "LONGCARD", LCard,    4);
  230.   EnterTyp(dbltyp,   "LONGINT",  Double,   4);
  231.   EnterTyp(realtyp,  "REAL",     Real,     4);
  232.   EnterTyp(lrltyp,   "LONGREAL", LongReal, 8);
  233.   EnterTyp(proctyp,  "PROC",     ProcTyp,  4);
  234.  
  235.   (*initialization of module SYSTEM*)
  236.   NewScope(Module);
  237.   expo := TRUE;
  238.   EnterTyp(bytetyp, "BYTE", Undef, 1);
  239.   EnterTyp(wordtyp, "WORD", Undef, 2);
  240.   EnterTyp(addrtyp, "ADDRESS", LCard, 4);
  241.   EnterProc('ADR',    Adr,    addrtyp);
  242.   EnterProc('TSIZE',  Tsize,  inttyp);
  243.   EnterProc('INLINE', Inline, notyp);
  244.   EnterProc('REG',    Reg,    dbltyp);
  245.   EnterProc('SETREG', Setreg, notyp);
  246.   EnterProc('SHIFT',  Shift,  inttyp);
  247.   EnterProc('LONG',   Long,   dbltyp);
  248.   EnterProc('SHORT',  Short,  inttyp);
  249.   EnterProc('VAL',    Val,    inttyp);
  250.   EnterProc('ASH',    XAsh,   inttyp);
  251.   EnterProc('COM',    XCom,   inttyp);
  252.   EnterProc('LSH',    XLsh,   inttyp);
  253.   EnterProc('MSK',    XMsk,   inttyp);
  254.   EnterProc('ROT',    XRot,   inttyp);
  255.   EnterProc('Sqrt',   Sqrt,   realtyp);
  256.   EnterProc('Entier', Entier, dbltyp);
  257.   EnterProc('Round',  Round,  dbltyp);
  258.  
  259.   ALLOCATE(sysmod, SIZE(Object));
  260.   WITH sysmod^ DO
  261.     name := Enter("SYSTEM"); class := Module; modno := 0; exported := FALSE;
  262.     left := NIL; right := NIL; next := NIL;
  263.     firstObj := topScope^.right; root := topScope^.right;
  264.     ALLOCATE(key, SIZE(Key))
  265.   END;
  266.   CloseScope;
  267.  
  268.   (* initialization of Universe continued *)
  269.   expo := FALSE;
  270.  
  271.   obj := NewObj(Enter("FALSE"), Const);
  272.   obj^.typ := booltyp; obj^.conval.B := FALSE;
  273.   obj := NewObj(Enter("TRUE"), Const);
  274.   obj^.typ := booltyp; obj^.conval.B := TRUE;
  275.   obj := NewObj(Enter("NIL"), Const);
  276.   obj^.typ := addrtyp; obj^.conval.D := NilVal;
  277.   bitstyp^.SBaseTyp := BBtyp;
  278.   WITH BBtyp^ DO
  279.     RBaseTyp := cardtyp; min := 0; max := WordSize - 1; size := 2;
  280.   END;
  281.   proctyp^.firstPar := NIL; proctyp^.resTyp := notyp;
  282.  
  283.   EnterProc('ABS',    Abs,    inttyp);
  284.   EnterProc('CAP',    Cap,    chartyp);
  285.   EnterProc('CHR',    Chr,    chartyp);
  286.   EnterProc('DEC',    Dec,    notyp);
  287.   EnterProc('EXCL',   Excl,   notyp);
  288.   EnterProc('FLOAT',  Float,  realtyp);
  289.   EnterProc('FLOATD', FloatD, lrltyp);
  290.   EnterProc('HALT',   Halt,   notyp);
  291.   EnterProc('HIGH',   High,   cardinttyp);
  292.   EnterProc('INC',    Inc,    notyp);
  293.   EnterProc('INCL',   Incl,   notyp);
  294.   EnterProc('LONG',   Long,   dbltyp);
  295.   EnterProc('MAX',    Max,    inttyp);
  296.   EnterProc('MIN',    Min,    inttyp);
  297.   EnterProc('ODD',    Odd,    booltyp);
  298.   EnterProc('ORD',    Ord,    cardinttyp);
  299.   EnterProc('SHORT',  Short,  inttyp);
  300.   EnterProc('SIZE',   Size,   cardinttyp);
  301.   EnterProc('TRUNC',  Trunc,  inttyp);
  302.   EnterProc('TRUNCD', TruncD, dbltyp);
  303.   MarkHeap
  304.  
  305. END M2TM. (* Copyright Departement Informatik, ETH Zuerich, Switzerland, 1992 *)
  306.